home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / pas_all.zip / TI227.ASC < prev    next >
Text File  |  1992-08-12  |  9KB  |  463 lines
  1.  
  2.  
  3.  
  4.  
  5.  
  6.  
  7.  
  8.  
  9.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  10.   VERSION : 3.01
  11.        OS : MS-DOS, PC-DOS, CP/M-86
  12.      DATE : August 4, 1986                               PAGE : 1/7
  13.     TITLE : TRANSCENDENTAL FUNCTIONS
  14.  
  15.  
  16.  
  17.  
  18.   The following example routines are public domain programs that
  19.   have been uploaded to our Forum on CompuServe. As a courtesy to
  20.   our users that do not have immediate access to CompuServe,
  21.   Technical Support distributes these routines free of charge.
  22.  
  23.   However, because these routines are public domain programs, not
  24.   developed by Borland International, we are unable to provide any
  25.   technical support or assistance using these routines. If you need
  26.   assistance using these routines, or are experiencing difficu
  27.  
  28.   Written by Randall A. Gacek
  29.  
  30.   This is a first approximation of a set of routines to do the
  31.   transcendental functions LOG, LN, SQRT, ARCTAN, SIN, COS and EXP
  32.   in the BCD version of Turbo Pascal.
  33.  
  34.   WARNING: The following code is specific to the implementation of
  35.   Turbo Pascal with BCD support. These functions should only be
  36.   used with this implementation.
  37.  
  38.   program checkfuncs;
  39.  
  40.   function sqrt(x:real):real;
  41.  
  42.   var
  43.     n,i,m :integer;
  44.     f,y   :real;
  45.     v     :record case boolean of
  46.               true:(y:real);
  47.              false:(z:array[1..10] of byte)
  48.             end;
  49.   begin
  50.     if x = 0.0 then
  51.       sqrt:=0.0
  52.     else if x < 0.0 then
  53.       halt
  54.     else begin
  55.       v.y:=x;
  56.       n:=v.z[1]-63;
  57.       v.z[1]:=63;
  58.       f:=v.y;
  59.       y:=0.580661+f/2.0-0.086462/(f+0.175241);
  60.       for i:=1 to 2 do
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67.  
  68.  
  69.  
  70.  
  71.  
  72.  
  73.  
  74.  
  75.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  76.   VERSION : 3.01
  77.        OS : MS-DOS, PC-DOS, CP/M-86
  78.      DATE : August 4, 1986                               PAGE : 2/7
  79.     TITLE : TRANSCENDENTAL FUNCTIONS
  80.  
  81.  
  82.  
  83.  
  84.         y:=0.5*(y+f/y);
  85.       y:=y+0.5*(f/y-y);
  86.       if odd(n) then
  87.       begin
  88.         y:=y*0.316227766016837933;
  89.         n:=n+1;
  90.       end;
  91.  
  92.   checkfuncs Con't.
  93.  
  94.       m:=n div 2;
  95.       v.y:=y;
  96.       v.z[1]:=v.z[1]+m;
  97.       sqrt:=v.y;
  98.     end;
  99.   end; { sqrt }
  100.  
  101.   function log(x:real):real;
  102.     const
  103.       c0= 0.316227766016837933;
  104.       a0=-0.260447002405557636E+2;
  105.       a1= 0.554085912041205931E+2;
  106.       a2=-0.392737410203156250E+2;
  107.       a3= 0.103338571514793865E+2;
  108.       a4=-0.741010784161919239E+0;
  109.       b0=-0.899552077881033117E+2;
  110.       b1= 0.245347618868489348E+3;
  111.       b2=-0.244303035341829542E+3;
  112.       b3= 0.107109789115668009E+3;
  113.       b4=-0.193732345832854786E+2;
  114.       c=  0.868588963806503655;
  115.  
  116.     var
  117.       n:integer;
  118.       xn,f,s,w,aw,bw,rs2,rs:real;
  119.       v:record case boolean of
  120.         true:(y:real);
  121.         false:(z:array[1..10] of byte)
  122.       end;
  123.  
  124.   begin
  125.     if x <= 0.0 then
  126.       halt;
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  142.   VERSION : 3.01
  143.        OS : MS-DOS, PC-DOS, CP/M-86
  144.      DATE : August 4, 1986                               PAGE : 3/7
  145.     TITLE : TRANSCENDENTAL FUNCTIONS
  146.  
  147.  
  148.  
  149.  
  150.     v.y:=x;
  151.     n:=v.z[1]-63;
  152.     v.z[1]:=63;
  153.     f:=v.y;
  154.     if f <= c0 then
  155.     begin
  156.       n:=n-1;
  157.       f:=f*10.0;
  158.     end;
  159.  
  160.  
  161.   checkfuncs Con't.
  162.  
  163.     s:=((f-0.5)-0.5)/(f+1.0);
  164.     w:=sqr(s);
  165.     aw:= (((a4*w+a3)*w+a2)*w+a1)*w+a0;
  166.     bw:=((((w+b4)*w+b3)*w+b2)*w+b1)*w+b0;
  167.     rs2:=w*aw/bw;
  168.     rs:=s*(c+rs2);
  169.     xn:=n;
  170.     log:=xn+rs;
  171.   end; { log }
  172.  
  173.   function ln(x:real):real;
  174.     const
  175.       c3=2.30258509299404568;
  176.  
  177.   begin
  178.       ln:=log(x)*c3;
  179.   end;
  180.  
  181.   function exp(x:real):real;
  182.     const
  183.       bigx=147.365445951618923;
  184.       smallx=-145.062860858624878;
  185.       eps=5.0e-19;
  186.       onelnsqrt10=0.868588963806503655;
  187.       c1=1.151;
  188.       c2=2.92546497022842009e-4;
  189.       p0=0.333267029226801611e+6;
  190.       p1=0.100974148724273918E+5;
  191.       p2=0.420414268137450315E+2;
  192.       q0=0.666534058453603223E+6;
  193.  
  194.  
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  208.   VERSION : 3.01
  209.        OS : MS-DOS, PC-DOS, CP/M-86
  210.      DATE : August 4, 1986                               PAGE : 4/7
  211.     TITLE : TRANSCENDENTAL FUNCTIONS
  212.  
  213.  
  214.  
  215.  
  216.       q1=0.757393346159883444E+5;
  217.       q2=0.841243584514154545E+3;
  218.       sqrt10=3.16227766016837933;
  219.     var
  220.       n:integer;
  221.       xn,g,z,gpz,qz,rg:real;
  222.       v:record case boolean of
  223.         true:(y:real);
  224.         false:(z:array[1..10] of byte)
  225.         end;
  226.  
  227.   checkfuncs Con't.
  228.  
  229.   begin
  230.     if x > bigx then
  231.       halt;
  232.     if x < smallx then
  233.       halt;
  234.     if abs(x) < eps then
  235.       exp:=1.0
  236.     else begin
  237.       n:=round(x*onelnsqrt10);
  238.       xn:=n;
  239.       g:=(x-xn*c1)-xn*c2;
  240.       z:=sqr(g);
  241.       gpz:=((p2*z+p1)*z+p0)*g;
  242.       qz:= ((z+q2)*z+q1)*z+q0;
  243.       rg:=(0.5+gpz/(qz-gpz))*2.0;
  244.       if odd(n) then
  245.         if n >= 0 then
  246.           rg:=sqrt10*rg
  247.         else
  248.           rg:=rg/sqrt10;
  249.       n:=n div 2;
  250.       v.y:=rg;
  251.       v.z[1]:=v.z[1]+n;
  252.       exp:=v.y;
  253.     end;
  254.   end; { exp }
  255.  
  256.   function sincos(x,y,sgn:real):real;
  257.     const
  258.       ymax=3141592654.0;
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  274.   VERSION : 3.01
  275.        OS : MS-DOS, PC-DOS, CP/M-86
  276.      DATE : August 4, 1986                               PAGE : 5/7
  277.     TITLE : TRANSCENDENTAL FUNCTIONS
  278.  
  279.  
  280.  
  281.  
  282.       onepi=0.318309886183790672;
  283.       c1= 3.141;                  { pi to 22 digits }
  284.       c2= 0.000592653589793238463;
  285.       eps=1.0e-9;
  286.       r1=-0.166666666666666651e+0;
  287.       r2= 0.833333333333316503E-2;
  288.       r3=-0.198412698412018405E-3;
  289.       r4= 0.275573192101527561E-5;
  290.       r5=-0.250521067982745845E-7;
  291.       r6= 0.160589364903715891E-9;
  292.       r7=-0.764291780689104677E-12;
  293.       r8= 0.272047909578888462E-14;
  294.  
  295.   checkfuncs Con't.
  296.  
  297.     var
  298.       xn,f,t,g,rg:real;
  299.   begin
  300.     if y >= ymax then
  301.       halt;
  302.     xn:=y*onepi;
  303.     xn:=int(xn+0.5);
  304.     if frac(xn / 2.0) <> 0.0 then
  305.       sgn:=-sgn;
  306.     if abs(x) <> y then { cos wanted }
  307.       xn:=xn-0.5;
  308.     f:=(abs(x)-xn*c1)-xn*c2;
  309.     if abs(f) < eps then
  310.       t:=f
  311.     else begin
  312.       g:=sqr(f);
  313.       rg:=(((((((r8*g+r7)*g+r6)*g+r5)*g+r4)*g+r3)*g+r2)*g+r1)*g;
  314.       t:=f+f*rg;
  315.     end;
  316.     sincos:=sgn*t;
  317.   end; { sincos }
  318.  
  319.   function sin(x:real):real;
  320.   begin
  321.     if x < 0.0 then
  322.       sin:=sincos(x,-x,-1.0)
  323.     else
  324.       sin:=sincos(x,x,1.0);
  325.  
  326.  
  327.  
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  
  336.  
  337.  
  338.  
  339.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  340.   VERSION : 3.01
  341.        OS : MS-DOS, PC-DOS, CP/M-86
  342.      DATE : August 4, 1986                               PAGE : 6/7
  343.     TITLE : TRANSCENDENTAL FUNCTIONS
  344.  
  345.  
  346.  
  347.  
  348.   end; {sin}
  349.  
  350.   function cos(x:real):real;
  351.   begin
  352.     cos:=sincos(x,abs(x)+1.57079632679489662,1.0);
  353.   end; {cos}
  354.  
  355.   checkfuncs Con't.
  356.  
  357.   function arctan(x:real):real;
  358.     const
  359.       twomsqrt3=0.267949192431122706;
  360.       sqrt3=1.73205080756887729;
  361.       a=0.732050807568877294;
  362.       eps=1e-9;
  363.       p0=-0.136887688941919269e+2;
  364.       p1=-0.205058551958616520e+2;
  365.       p2=-0.849462403513206835e+1;
  366.       p3=-0.837582993681500593e+0;
  367.       q0= 0.410663066825757813e+2;
  368.       q1= 0.861573495971302425e+2;
  369.       q2= 0.595784361425973445e+2;
  370.       q3= 0.150240011600285761e+1;
  371.  
  372.     var
  373.       n:integer;
  374.       f,result,g,gpg,qg,r:real;
  375.   begin
  376.     f:=abs(x);
  377.     if f > 1.0 then
  378.     begin
  379.       f:=1.0/f;
  380.       n:=2;
  381.     end
  382.     else
  383.       n:=0;
  384.     if f > twomsqrt3 then
  385.     begin
  386.       f:=(((a*f-0.5)-0.5)+f)/(sqrt3+f);
  387.       n:=n+1;
  388.     end;
  389.     if abs(f) < eps then
  390.       result:=f
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.   PRODUCT : TURBO PASCAL WITH BCD SUPPORT              NUMBER : 227
  406.   VERSION : 3.01
  407.        OS : MS-DOS, PC-DOS, CP/M-86
  408.      DATE : August 4, 1986                               PAGE : 7/7
  409.     TITLE : TRANSCENDENTAL FUNCTIONS
  410.  
  411.  
  412.  
  413.  
  414.     else begin
  415.       g:=sqr(f);
  416.       gpg:=(((p3*g+p2)*g+p1)*g+p0)*g;
  417.       qg:=(((g+q3)*g+q2)*g+q1)*g+q0;
  418.       r:=gpg/qg;
  419.       result:=f+f*r;
  420.     end;
  421.     if n > 1 then
  422.       result:=-result;
  423.  
  424.   checkfuncs Con't.
  425.  
  426.     case n of
  427.       0:;
  428.       1:result:=0.523598775598298873+result;
  429.       2:result:=1.57079632679489662+result;
  430.       3:result:=1.04719755119659775+result;
  431.     end;
  432.     if x < 0.0 then
  433.       result:=-result;
  434.     arctan:=result;
  435.   end; { arctan }
  436.  
  437.   begin
  438.     writeln('sqrt= ',sqrt(25));
  439.     writeln('ln = ',ln(25));
  440.     writeln('exp = ',exp(25));
  441.     writeln('cos = ',cos(25));
  442.     writeln('sin = ',sin(25));
  443.     writeln('log = ',log(25));
  444.     writeln('arctan = ',arctan(25));
  445.   end.
  446.  
  447.  
  448.   DISCLAIMER: You have the right to use this technical information
  449.   subject to the terms of the No-Nonsense License Statement that
  450.   you received with the Borland product to which this information
  451.   pertains.
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  
  461.  
  462.  
  463.